#!/usr/bin/perl -w

package C_server2;

use strict;
use Socket;
use Sys::Hostname;
use Digest::SHA1 qw(sha1 sha1_hex);
use Crypt::Blowfish;
use Crypt::CBC;
use Data::Dumper;

#########################################################################
# Optionally get hold of Crypt::RSA for PKI support.			#
#########################################################################

BEGIN {
	$C_server2::PKI=1;
	eval 'use Crypt::RSA;';
	$C_server2::PKI=0 if $@;
}

sub _dprint(@) {
	return if ! $::DEBUG;
	print STDERR "DEBUG: ",@_;
}

if($C_server2::PKI==1 && exists($::ENV{TRUECL_PKI})) {
	$C_server2::PKI=$::ENV{TRUECL_PKI};
}

my $error_str=undef;
sub error {
	return $error_str;
}

#########################################################################
# This routine will scan all window keys under TRUECL_CFG/keys and	#
# will load all of them.						#
#########################################################################

sub load_window_keys {
my $self = shift;

my $dfd;
my $fd;
my $server;
my $key;
my %client_keys;
my $cfile;

	if(! -d "$::ENV{TRUECL_CFG}/keys") {
		return 0;
	}
	%client_keys=();
	opendir($dfd,"$::ENV{TRUECL_CFG}/keys") or return(0);
	while($cfile=readdir($dfd)) {
		next if $cfile !~ /.*\.key$/;
		next if ! -f "$::ENV{TRUECL_CFG}/keys/$cfile";
		open($fd,"$::ENV{TRUECL_CFG}/keys/$cfile") or return(0);
		my ($key,$window);
		$key=<$fd>; chomp $key;
		$window=<$fd>; chomp $window;
		($server)=($cfile =~ /(.*)\.key$/);
		$client_keys{$server}=[$key,int($window)]
	}
	CORE::close $fd;
	$self->{CLIENT_HASH}=\%client_keys;
	_dprint "Loaded window keys:",Dumper(\%client_keys);
	return 1;
}

sub _get_client_key {
my $self = shift;
my $hashref;

	$hashref=$self->{CLIENT_HASH};
	if(! exists $$hashref{$_[0]}) {
		_dprint "Failed to find client information for $_\n";
		return undef;
	}
	_dprint "Client information found: $$hashref{$_[0]}->[0],$$hashref{$_[0]}->[1]\n";
	return ($$hashref{$_[0]}->[0],$$hashref{$_[0]}->[1]);
}

#########################################################################
# The new method below requires a client keys file to be passed to 	#
# ensure details of the clients can be accessed when a request from	#
# a client is accepted.							#
# The actual arguments that must be passed to the new method are:	#
# PORT => N								#
# [PKI => 0|1]								#
#									#
# If RSA PKI is to be supported the TRUECL_CFG/pki directory is		#
# expected to hold details of the server private key and any client	#
# public keys. Name is hostname.public or hostname.private.		#
#########################################################################

sub new {
my $proto = shift;
my $class = ref($proto) || $proto;
my $self = {};
my ($serv,$lh);
my %args=@_;

	if(!exists($args{PORT})) {
		die("Object definition not past mandatory PORT argument.");
	}
	my $port=$args{PORT};
	if(exists($args{PKI}) && $args{PKI}) {
		die("Local host does not support PKI.") if ! $C_server2::PKI;
		$self->{PKI}=1;

		#########################################################################
		# We do not know which clients will attempt to attach to use, but	#
		# we need our private key to decode the requests, and set up an array	#
		# to hold the client public keys and load them as needed.		#
		#########################################################################

		$self->{PKI_CLIENT_PUBLIC_KEYS}={};
		my $d="$::ENV{TRUECL_CFG}/pki";
		my $h=hostname;
		
		#########################################################################
		# Attempt to load in our private key and abort on problems.		#
		#########################################################################

		if(! -e "$d/$h.private") {
			$error_str="Missing Local private key: $d/$h.private.";
			return undef;
		}
		_dprint "Private key found in: $d/$h.private\n";
		my $private=new Crypt::RSA::Key::Private(Filename => "$d/$h.private");
		if(!defined($private)) {
			_dprint "Failed to load RSA key from $d/$h.private.\n";
			$error_str="Unable to load Private key for localhost!";
			return undef;
		}
		$self->{PKI_RSA}=new Crypt::RSA;
		if(!defined($self->{PKI_RSA})) {
			die("Unable to generate RSA object!");
		}
		_dprint "Defined a Crypt::RSA object OK.\n";
		$self->{PKI_SERVER_PRIVATE}=$private;
	} else {
		$self->{PKI}=0;
	}

	#################################################################
	# Whether RSA-based encryption is supported or not, load in	#
	# key/window pairs if available.				#
	#################################################################

	$self->{CLIENT_HASH}={};
	load_window_keys($self);

	$error_str=undef;
	if(!socket($serv,PF_INET,SOCK_STREAM,getprotobyname('tcp'))) {
		$error_str="Unable to create 'tcp' socket: $!";
		return(undef);
	}

	if(!setsockopt($serv,SOL_SOCKET, SO_REUSEADDR,pack("l", 1))) {
		$error_str="Unable to set socket options: $!";
		return(undef);
	}

	if(!bind($serv,sockaddr_in($args{PORT}, INADDR_ANY))) {
		$error_str="Unable to bind to socket: $!";
		return(undef);
	}

	if(!listen($serv,SOMAXCONN)) {
		$error_str="Unable to set maximum socket connections: $!";
		return(undef);
	}

	$self->{PORT}        = $port;		# Port to listen on
	$self->{SOCKET}      = $serv;		# Opened socket to listen on
	$self->{KEY}         = undef;		# Initial key for client
	$self->{NEWKEY}      = undef;		# Key negociated with client
	$self->{NEW_SOCKET}  = undef;		# Spawned child socket...
	$self->{TIMEOUT}     = 0;		# Timeout waiting for response, 
						# 0 no timeout
	$self->{WINDOW}	     = 63;		# Key time window

	bless($self,$class);
	return $self;
}

sub set_params {
my $self=shift;
my %args=@_;

	if(exists($args{WINDOW})) {
		$self->{WINDOW}=$args{WINDOW};
		delete $args{WINDOW};
	}
	if(exists($args{TIMEOUT})) {
		$self->{TIMEOUT}=$args{TIMEOUT};
		delete $args{TIMEOUT};
	}
	if(scalar(keys(%args))) {
		return 0;
	}
	return 1;
}

#########################################################################
# The accept method is called when the server wishes to wait for	#
# a connection from a client...						#
# It will return (data,undef) - where data is a decode request.		#
# or (undef,error) - indicating an error occured.			#
# or (undef,undef) - timeout waiting for a request			#
# Optional parameter is number of seconds to wait for a connection -	#
# can be fractional. After this time will return with (undef,undef
#########################################################################

sub close {
my $self = shift;

	CORE::close($self->{SOCKET});
	
}

sub accept {
my $self = shift;
my $sh;
my $new_fd;
my ($paddr,$client);
my $sha1_hex;
my ($sender,$msg,$sha1);
my $timeout=shift;

	if(!defined($timeout)) {
		$timeout=$self->{TIMEOUT};
	}
	
	my ($rout,$rin,$win,$ein,$nfound);
	$rin = $win = $ein = '';
	vec($rin,fileno($self->{SOCKET}),1) = 1;
	$ein = $rin | $win;

	if($timeout > 0) {
		$rout='';
		$nfound=select($rout=$rin, undef, undef, $timeout);
		if(!$nfound || !vec($rout, fileno($self->{SOCKET}), 1)) {
			return(undef,undef);
		}
	}

	$paddr=accept($client,$self->{SOCKET});
	return(undef,"SOCKET ERROR:Unable to accept on Socket") if !defined($paddr);

	my ($port,$iaddr) = sockaddr_in($paddr);

	_dprint "Accepted connection via $iaddr:$port\n";
	#################################################################
	# Set up auto-flush on the socket handle			#
	#################################################################
	$new_fd=select($client);
	$|=1;
	select($new_fd);

	#################################################################
	# If we get this far read in the request as well...		#
	#################################################################

	$msg=<$client>;
	my $rtime=time;
	my $window=$self->{WINDOW};

	if(!defined($msg)) {
		CORE::close $client;
		return (undef,"PROTOCOL ERROR: No data to read from socket!");
	}
	chomp $msg;
	_dprint "Message accepted: $msg\n";

	#################################################################
	# The message will be in the following format:			#
	# sender|msg|SHA1						#
	# or:								#
	# sender|RSA|msg						#
	#################################################################

	($sender,$msg,$sha1)=split(/\|/,$msg);
	if(!defined($sender) || !defined($msg) || !defined($sha1)) {
		$msg="Packet not in expected format.";
		$sha1_hex=sha1_hex($msg);
		$msg=unpack("H*",$msg) . "|$sha1_hex";
		print $client "E|$msg\n";
		CORE::close($client);
		_dprint "Message not in expected format!!\n";
		return (undef,"PROTOCOL ERROR: Packet not in expected format.");
	}
	_dprint "Decoded to: (sender=$sender,msg=$msg,sha1=$sha1)\n";

	#################################################################
	# Handle the RSA encrypt/decrypt fisrt if necessary.		#
	#################################################################

	_dprint "sender=$sender\n";
	_dprint "msg   =$msg\n";
	_dprint "sha1  =$sha1\n";

	if($msg eq "RSA") {
		#########################################################
		# If PKI is not configured about with error.		#
		#########################################################
		$self->{SENDER_PKI}=1;
		if($self->{PKI}==0) {
			$msg="Server does not support RSA PKI protocol.";
			$sha1_hex=sha1_hex($msg);
			$msg=unpack("H*",$msg) . "|$sha1_hex";
			print $client "E|$msg\n";
			CORE::close($client);
			return (undef,"SECURITY ERROR: Client sent RSA PKI protocol requested - but not supported by server.");
		}
		if(!exists($self->{PKI_CLIENT_PUBLIC_KEYS}->{$sender})) {
			my $d="$::ENV{TRUECL_CFG}/pki";

			if(! -e "$d/$sender.public") {
				$msg="Missing Sender Public Key: $d/$sender.public.";
				_dprint "$msg\n";
				$sha1_hex=sha1_hex($msg);
				$msg=unpack("H*",$msg) . "|$sha1_hex";
				print $client "E|$msg\n";
				CORE::close($client);
				return (undef,"SECURITY ERROR: Sender Public Key $sender.public not available.");
			}
			_dprint "RSA : Loading information from '$d/$sender.public'\n";

			my $public=new Crypt::RSA::Key::Public(Filename => "$d/$sender.public");
			if(!defined($public)) {
				$msg="Unable to load Sender Public Key: $d/$sender.public.";
				_dprint "$msg\n";
				$sha1_hex=sha1_hex($msg);
				$msg=unpack("H*",$msg) . "|$sha1_hex";
				print $client "E|$msg\n";
				CORE::close($client);
				return (undef,"SECURITY ERROR: Unable to load Sender Public Key $sender.public.");
			}
			_dprint "Loaded: \n",Dumper($public);
			$self->{PKI_CLIENT_PUBLIC_KEYS}->{$sender}=$public;
		}
		my $dec=pack("H*",$sha1);
		my $plain_text;
		eval {
			$plain_text=$self->{PKI_RSA}->decrypt(Cyphertext => $dec,Armour => 0,
					Key => $self->{PKI_SERVER_PRIVATE});
		};
		if($@ || !defined($plain_text)) {
			_dprint "RSA : Decode failure : ",$self->{PKI_RSA}->errstr,"\n";

			$msg=hostname . " Unable to decode message from $sender (Incorrect Key Pair?)";
			_dprint "$msg\n";
			$sha1_hex=sha1_hex($msg);
			$msg=unpack("H*",$msg) . "|$sha1_hex";
			print $client "E|$msg\n";
			CORE::close($client);
			return (undef,"SECURITY ERROR: Unable to decrypt message for $sender (Incorrect key pair?)");
		}
		$self->{CLIENT}=$client;
		$self->{CLIENT_NAME}=$sender;
		return ($plain_text,undef);
	}

	#################################################################
	# Get the key from the client and return error if known.	#
	#################################################################
	$self->{SENDER_PKI}=0;
	my $key;
	($key,$window) = _get_client_key($self,$sender);
	if(! defined $key) {
		$msg="Host not authorised to connect to server.";
		_dprint "$msg\n";
		$sha1_hex=sha1_hex($msg);
		$msg=unpack("H*",$msg) . "|$sha1_hex";
		print $client "E|$msg\n";
		CORE::close($client);
		return (undef,"Unknown host requestor");
	}

	#################################################################
	# Attempt the current window time, the previous and finally 	#
	# the next and abort if not matched.				#
	#################################################################

	$self->{CLIENT}=$client;
	$self->{CLIENT_NAME}=$sender;
	my $time=$rtime&(~int($window));
	my $key2="$key+$time";
	_dprint "[1st] Attempting to decode client request using key=$key2\n";
	my $cipher=new Crypt::CBC($key2,"Blowfish");
	my $plain_text=$cipher->decrypt_hex($msg);
	$sha1_hex=sha1_hex($plain_text);
	_dprint "Decrypted to: $plain_text\n";
	if($sha1_hex eq $sha1) {
		$self->{CURRENT_KEY}=$key2;
		return ($plain_text,undef);
	}

	#################################################################
	# Attempt the next time window...				#
	#################################################################

	$time=($rtime+(1+$window))&(~$window);
	$key2="$key+$time";
	_dprint "[2nd] Attempting to decode client request using key=$key2\n";
	$cipher=new Crypt::CBC($key2,"Blowfish");
	$plain_text=$cipher->decrypt_hex($msg);
	$sha1_hex=sha1_hex($plain_text);
	if($sha1_hex eq $sha1) {
		$self->{CURRENT_KEY}=$key2;
		return ($plain_text,undef);
	}

	#################################################################
	# Attempt the previous time window...				#
	#################################################################

	$time=($rtime-(1+$window))&(~int($window));
	$key2="$key+$time";
	_dprint "[3rd] Attempting to decode client request using key=$key2\n";
	$cipher=new Crypt::CBC($key2,"Blowfish");
	$plain_text=$cipher->decrypt_hex($msg);
	$sha1_hex=sha1_hex($plain_text);
	if($sha1_hex eq $sha1) {
		$self->{CURRENT_KEY}=$key2;
		return ($plain_text,undef);
	}

	#################################################################
	# Get here the client/server window is too large, so send an	#
	# appropriate error to the clint.				#
	#################################################################

	_dprint "Uable to decrypt client request using any key!\n";
	delete($self->{CLIENT});
	$msg="Client server time different beyond security window ($window seconds), or incorrect key.";
	_dprint "$msg\n";
	$sha1_hex=sha1_hex($msg);
	$msg=unpack("H*",$msg) . "|$sha1_hex";
	print $client "E|$msg\n";
	CORE::close($client);
	return (undef,"PROTOCOL ERROR: Client/Server time difference too great, or incorrect key.");
}

sub no_response {
my $self = shift;
my $sock=$self->{CLIENT};

	CORE::close($sock);
}

sub send_response {
my $self = shift;

my $key=$self->{CURRENT_KEY};
my $sock=$self->{CLIENT};
my $msg=$_[0];

my $sha1_sum;
my $md5_sum2;
my $packed_msg;
my $cipher;
my $crypted_msg;
my $sender;
my $pki;

	$sender=$self->{CLIENT_NAME};
	$pki=$self->{SENDER_PKI};

	#################################################################
	# Now we have encrypted the message including the checksum	#
	# we attempt to send the result back to the client.		#
	# If non RSA PKI then the format will be:			#
	# R|hex-enc-crypted-sg|SHA1					#
	# else:								#
	# R|HEX-rsa-crypted-sg|RSA					#
	#################################################################

	if($self->{SENDER_PKI}) {
		$crypted_msg=$self->{PKI_RSA}->encrypt(
			Message => $msg,
			Key     => $self->{PKI_CLIENT_PUBLIC_KEYS}->{$sender},
			Armour	=> 0);
		$crypted_msg=unpack("H*",$crypted_msg);
		$sha1_sum="RSA";
	} else {

		#########################################################
		# Firstly we generate a checksum of the message to send	#
		#########################################################

		$sha1_sum=sha1_hex($msg);

		#########################################################
		# Now we turn the message into hex...			#
		#########################################################

		$cipher=new Crypt::CBC($key,"Blowfish");
		$crypted_msg=$cipher->encrypt_hex("$msg");
	}
	if( ! (print $sock "R|$crypted_msg|$sha1_sum\n")) {
		CORE::close $sock;
		delete($self->{CLIENT}) if exists($self->{CLIENT});
		delete($self->{CURRENT_KEY}) if exists($self->{CURRENT_KEY});
		return(0,"Socket Error: Unable to send request to client.");
	}
	CORE::close $sock;
	delete($self->{CLIENT});
	delete($self->{CURRENT_KEY});
	return(1,undef);
}

1;

__END__

=head1 NAME

C_server2 - Simplified server-side library for Encrypted Sockets

=head1 SYNOPSIS

    use C_server2;
    
    $port=7788;
    $server=new C_server2($port);
    $server->load_file("filesfile");
    $server->add_key("host","key");

    while (($request,$err) = $server->accept) {
        next if !defined($request) && !defined($err);

	# Above is socket timeout  - all requests
	# must be synchronous, not forking!

	if(defined($err)) {
		print "Error: $err\n";
		next;
	}

	$response=handle_msg($request);
	($res,$err)=$server->send_response($response);
	if(!$res) {
		print "Error: Unable to send response: $err\n";
        }

	# Loop around and accept the next request.
    }

=head1 DESCRIPTION

The C_server2 package implements the server side functionality of the
Simplified Encrypted Socket Layer, allowing secure client/server
communication over sockets.

The C_server2 package can be used to create a server object which can
accept and respond to requests issued by clients using the
C_client2 package.

Unlike the previous version this one has been simplified - indeed as it
stands if will not work in a multi-forking environment - only a 
straight forward synchronous module.

=head1 Supported Methods

=over 4

=item B<new>

When creating a new server object using there is just a single parameter:

=over 4

=item B<port>

This is the port number on which the server is to listen. This must be the
number - if you want to use a name from /etc/services, then you must perform
any name to number translation first.

=back

The B<new> call will create an server object, or if an error occurs will
return the B<undefined> value.

=item B<load_file>

Allows a series of client names and associated keys to be loaded from
a text file. Each line in the text file must be in the format:

client    key

=item B<add_key>

This can be used to add a single client key and thus takes two arguments:

=over 4

=item B<client>

This is the name of the client the key is being registered for.

=item B<key>

This is the key of the specified client.

=back

=item B<set_params>

This method allows the default timing window and accept time out on the
socket to be modified. The default values are 63 and 0 respectively.

The arguemnts expected are:

=over 4

=item B<window>

This timing window for accepting encryption - must be a value of 31,63,127 or
255. The smaller the value the more time synchronous the hosts must be.

=item B<timeout>

The length of time whlst awaiting on the accept system call - in seconds. If
0 it will wait forever or an error/interrupt occurs.

=back

=item B<accept>

This method is used by the server to wait and accept a client connection
on the newly created socket. When it returns it will return two values:

=over 4

=item B<data>

The accepted unencrypted request from the client.

=item B<send_response>

Sends a response back to the client that currently has an active 
connection to the server using the same key they used to send the
request. It expects a single argument:


=over 4

=item B<msg>

The message to send back to the client.

=back

It returns a two element list:

=over 4

=item B<returncode>

This will be 1 if successfully sent the response, or 0 on error.

=item B<error_msg>

An error string or undef if no error has occured.

=back

